home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / tspa3150.zip / TSUNTENV.TST < prev    next >
Text File  |  1992-08-20  |  3KB  |  105 lines
  1. {$M 16384,0,0}
  2. {$R+}
  3.  
  4. program tsuntenvTest;
  5.  
  6. uses Dos,
  7.      TSUNTENV,
  8.      TSUNTE;     (* To include the routine getting the command line *)
  9.  
  10. procedure LOGO;
  11. begin
  12.   writeln;
  13.   writeln ('TSUNTENV unit test by Prof. Timo Salmi, 20-Aug-92');
  14.   writeln ('University of Vaasa, Finland, ts@uwasa.fi');
  15.   writeln;
  16. end;  (* logo *)
  17.  
  18. function HEXFN (decimal : word) : string;
  19. const hexDigit : array [0..15] of char = '0123456789ABCDEF';
  20. begin
  21.   hexfn := hexDigit[(decimal shr 12)]
  22.         + hexDigit[(decimal shr 8) and $0F]
  23.         + hexDigit[(decimal shr 4) and $0F]
  24.         + hexDigit[(decimal and $0F)];
  25. end;  (* hexfn *)
  26.  
  27. (* Demonstrate some information about the parent environment *)
  28. procedure TEST1;
  29. var envsize : word;
  30.     envuse  : word;
  31.     envaddr : string;
  32. begin
  33.   envsize := ENVSIZFN;
  34.   writeln ('The environment size is ', envsize:5, ' bytes');
  35.   envuse := ENVUSEFN;
  36.   writeln ('The environment use  is ', envuse:5, ' bytes');
  37.   envaddr := '$' + HEXFN(ENVADDFN);
  38.   writeln ('The environment segment address is ', envaddr);
  39.   SHOWENV;
  40. end;  (* test1 *)
  41.  
  42. procedure TEST2;
  43. var status : byte;
  44.     newset : string;
  45. begin
  46.   newset := copy (CMDLNFN, 2, 255);           (* From TSUNTE *)
  47.   if newset <> '' then
  48.     begin
  49.       SETENV (newset, status);
  50.       case status of
  51.         0 : writeln ('No errors detected');
  52.         1 : writeln ('Syntax error (Usage: variable=value)', #7);
  53.         2 : writeln ('Out of environment space', #7);
  54.         3 : writeln ('Missed the variable or the environment', #7);
  55.       end;
  56.     end
  57.   else
  58.     writeln ('Usage: TSUNTENV.EXE name=value');
  59. end;  (* test2 *)
  60.  
  61. (* Test setting the invironment variable for the duration of shelling
  62.    to MsDos *)
  63. procedure TEST3;
  64. var comspec : string;
  65.     error   : integer;
  66. begin
  67.   {}
  68.   comspec := GetEnv ('comspec');
  69.   SETENVSH ('TEST_LONG_ENVIRONMENT', 'testing_the_environment');
  70.   SETENVSH ('PROMPT', '$p$g[SHELLED] ');
  71.   {}
  72.   writeln ('Type EXIT to return to TSUNTENV');
  73.   writeln ('Write SET to see the current environment variable values');
  74.   swapvectors;
  75.   Exec (comspec, '');   {execute the DOS shell}
  76.   swapvectors;
  77.   {}
  78.   error := DosError;
  79.   if error <> 0 then
  80.     begin
  81.       writeln ('Cannot run MsDos shell');
  82.       if error = 8 then
  83.          writeln ('Out of memory')
  84.        else
  85.          writeln ('Command processor ', comspec, ' not found');
  86.       halt;
  87.     end;
  88.   {}
  89.   writeln ('Back from shell');
  90.   writeln ('Write SET to see the current environment variable values');
  91. end;  (* test3 *)
  92.  
  93. (* Main program *)
  94. begin
  95.   LOGO;
  96.   {
  97.   TEST3;
  98.   TEST1;
  99.   }
  100.   TEST2;
  101.   TEST1;
  102.   {}
  103.   { write ('Press <-'' '); readln; }
  104. end.  (* tsuntenv.tst *)
  105.